home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / defmacro.ss < prev    next >
Text File  |  1993-11-07  |  3KB  |  118 lines
  1. ;defmacro.ss
  2. ;SLaTeX Version 1.99
  3. ;define-macro! for SLaTeX
  4. ;(c) Dorai Sitaram, December 1991, Rice University
  5.  
  6. ;define-macro!
  7.  
  8. '(enable cl)
  9. (defmacro define-macro! z `(defmacro ,@z))
  10.  
  11. '(enable cscheme)
  12. (syntax-table-define system-global-syntax-table
  13.   'define-macro!
  14.   (macro defmacargs
  15.     (let ((macname (car defmacargs)) (macargs (cadr defmacargs))
  16.       (macbdy (cddr defmacargs)))
  17.       `(syntax-table-define system-global-syntax-table
  18.      ',macname
  19.      (macro ,macargs ,@macbdy)))))     
  20.  
  21. '(enable elk)
  22. (define-macro (define-macro! key pat . bdy)
  23.   `(define-macro ,(cons key pat) ,@bdy))
  24.  
  25. '(enable schemetoc)
  26. (define-macro define-macro!
  27.   (lambda (f e)
  28.     (let ((key (cadr f)) (pat (caddr f)) (bdy (cdddr f)))
  29.       (e `(define-macro ,key 
  30.         (lambda (%form% %expr%)
  31.           (%expr% (apply (lambda ,pat ,@bdy) (cdr %form%)) %expr%)))
  32.      e))))
  33.  
  34. '(enable scmx)
  35. (define-syntax extend-syntax
  36.   (syntax-rules ()
  37.     ((extend-syntax (macro . keywords) . clauses)
  38.      (define-syntax macro
  39.        (syntax-rules keywords . clauses)))))
  40.  
  41. '(enable umbscheme)
  42. (macro define-macro!
  43.   (lambda (f)
  44.     (let ((key (cadr f)) (pat (caddr f)) (bdy (cdddr f)))
  45.       `(macro ,key (lambda (%temp%)
  46.              (apply (lambda ,pat ,@bdy) (cdr %temp%)))))))
  47.  
  48. '(enable) ;alternative for potential dialect
  49. (define-macro define-macro!
  50.   (lambda (key pat . bdy)
  51.     `(define-macro ,key
  52.        (lambda ,pat ,@bdy))))
  53.  
  54. '(enable) ;alternative for potential dialect
  55. (define-syntax (define-macro! key pat . bdy)
  56.   `(define-syntax ,(cons key pat) ,@bdy))
  57.  
  58. ;when
  59.  
  60. '(enable scmx)
  61. (extend-syntax (when)
  62.   ((when a . b) (if a (begin . b) 'void)))
  63.  
  64. '(disable chez cl elk scmx)
  65. (define-macro! when (a . b)
  66.   `(if ,a (begin ,@b) 'void))
  67.  
  68. ;unless
  69.  
  70. '(enable scmx)
  71. (extend-syntax (unless)
  72.   ((unless a . b) (if a 'void (begin . b))))
  73.  
  74. '(disable chez cl elk scmx)
  75. (define-macro! unless (a . b)
  76.   `(if ,a 'void (begin ,@b)))
  77.  
  78. ;gensym
  79.  
  80. '(disable chez cl)
  81. (define gensym
  82.   (let ((n -1))
  83.     (lambda ()
  84.       ;generates an allegedly new symbol;
  85.       ;this is a gross hack since there is no standardized way of
  86.       ;getting uninterned symbols
  87.       (set! n (+ n 1))
  88.       (string->symbol (string-append "#:g%" (number->string n) "%")))))
  89.  
  90. ;fluid-let
  91.  
  92. '(enable cl)
  93. (define-macro! fluid-let (let-pairs . body)
  94.   `(let ,let-pairs
  95.      (declare (special ,@(map car let-pairs)))
  96.      ,@body))
  97.  
  98. '(enable scmx)
  99. (extend-syntax (fluid-let) ;caveat: this is really fluid-let*
  100.   ((fluid-let () . body) (begin . body))
  101.   ((fluid-let ((x v) . more-let-pairs) . body)
  102.    (let ((%tmp x))
  103.      (set! x v)
  104.      (let ((%ans (fluid-let more-let-pairs . body)))
  105.        (set! x %tmp)
  106.        %ans))))
  107.  
  108. '(disable chez cl cscheme elk scmx)
  109. (define-macro! fluid-let (let-pairs . b)
  110.   (let ((x-s (map car let-pairs))
  111.     (i-s (map cadr let-pairs))
  112.     (old-x-s (map (lambda (p) (gensym)) let-pairs)))
  113.     `(let ,(map (lambda (old-x x) `(,old-x ,x)) old-x-s x-s)
  114.        ,@(map (lambda (x i) `(set! ,x ,i)) x-s i-s)
  115.        (let ((%temp% (begin ,@b)))
  116.      ,@(map (lambda (x old-x) `(set! ,x ,old-x)) x-s old-x-s)
  117.      %temp%))))
  118.